home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue48 / Clinic / MonitorU.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-05-26  |  3.1 KB  |  123 lines
  1. unit MonitorU;
  2.  
  3. interface
  4.  
  5. uses
  6. {$ifdef Ver90} //Delphi 2
  7.   DB,
  8. {$else} //Delphi 3+
  9.   DBTables,
  10. {$endif}
  11.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  12.   StdCtrls, Buttons;
  13.  
  14. type
  15.   TSQLTraceForm = class(TForm)
  16.     Label1: TLabel;
  17.     Label2: TLabel;
  18.     lstTrace: TListBox;
  19.     memTrace: TMemo;
  20.     TraceCategories: TGroupBox;
  21.     CBPrepared: TCheckBox;
  22.     CBExecuted: TCheckBox;
  23.     CBInputParams: TCheckBox;
  24.     CBFetchedData: TCheckBox;
  25.     CBStatement: TCheckBox;
  26.     CBConnect: TCheckBox;
  27.     CBTransaction: TCheckBox;
  28.     CBBlob: TCheckBox;
  29.     CBMisc: TCheckBox;
  30.     CBVendorErr: TCheckBox;
  31.     CBVendor: TCheckBox;
  32.     btnClear: TSpeedButton;
  33.     chkAutoScroll: TCheckBox;
  34.     procedure FormCreate(Sender: TObject);
  35.     procedure FormDestroy(Sender: TObject);
  36.     procedure lstTraceClick(Sender: TObject);
  37.     procedure btnClearClick(Sender: TObject);
  38.     procedure CheckBoxClick(Sender: TObject);
  39.   private
  40.     FFileView: Pointer;
  41.     FMemFile: THandle;
  42.     FDLL: HModule;
  43.   public
  44.     function GetTraceOptions: Integer;
  45.     procedure WndProc(var Msg: TMessage); override;
  46.   end;
  47.  
  48. var
  49.   SQLTraceForm: TSQLTraceForm;
  50.  
  51. implementation
  52.  
  53. uses
  54.   MonHelpU;
  55.  
  56. {$R *.DFM}
  57.  
  58. procedure TSQLTraceForm.FormCreate(Sender: TObject);
  59. begin
  60.   //Give listbox a horizontal scroll bar
  61.   SendMessage(lstTrace.Handle, lb_SetHorizontalExtent, 2000, 0);
  62.   FDLL := LoadLibrary('MonLib.Dll');
  63.   if FDLL <= 32 then
  64.     ShowMessage('Cannot load support library');
  65.   FMemFile := OpenFileMapping(FILE_MAP_READ, False, 'SMBuffer');
  66.   if FMemFile = 0 then
  67.     raise Exception.Create('Cannot open file mapping');
  68.   FFileView := MapViewOfFile(FMemFile, FILE_MAP_READ, 0, 0, TraceBufSize);
  69.   if FFileView = nil then
  70.     raise Exception.Create('Cannot open file view');
  71. end;
  72.  
  73. procedure TSQLTraceForm.FormDestroy(Sender: TObject);
  74. begin
  75.   CloseHandle(FMemFile);
  76.   if FDLL > 32 then
  77.     FreeLibrary(FDLL)
  78. end;
  79.  
  80. function TSQLTraceForm.GetTraceOptions: Integer;
  81. var
  82.   Loop: Integer;
  83. begin
  84.   Result := 0;
  85.   for Loop := 0 to TraceCategories.ControlCount - 1 do
  86.     if (TraceCategories.Controls[Loop] is TCheckBox) and
  87.       TCheckBox(TraceCategories.Controls[Loop]).Checked then
  88.         Inc(Result, TCheckBox(TraceCategories.Controls[Loop]).Tag);
  89. end;
  90.  
  91. procedure TSQLTraceForm.WndProc(var Msg: TMessage);
  92. begin
  93.   inherited;
  94.   if Msg.Msg = wm_TraceMessage then
  95.   begin
  96.     Msg.Result := 1;
  97.     lstTrace.Items.Add(StrPas(PChar(FFileView)));
  98.     if chkAutoScroll.Checked then
  99.       lstTrace.ItemIndex := lstTrace.Items.Count - 1
  100.   end
  101.   else
  102.   if Msg.Msg = wm_ClientLibNotify then
  103.     SendMessage(TWMClientLibNotify(Msg).Wnd, wm_MonitorNotify, Handle, GetTraceOptions);
  104. end;
  105.  
  106. procedure TSQLTraceForm.lstTraceClick(Sender: TObject);
  107. begin
  108.   memTrace.Text := lstTrace.Items[lstTrace.ItemIndex]
  109. end;
  110.  
  111. procedure TSQLTraceForm.btnClearClick(Sender: TObject);
  112. begin
  113.   lstTrace.Clear
  114. end;
  115.  
  116. procedure TSQLTraceForm.CheckBoxClick(Sender: TObject);
  117. begin
  118.   //Notify clients of new trace flags
  119.   SendMessage(HWnd_Broadcast, wm_UpdateClients, GetTraceOptions, 0)
  120. end;
  121.  
  122. end.
  123.